Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/Src/Ch14/Surface2.frm

Visual Basic Form | 1999-06-22 | 12.1 KB | 406 lines

VERSION 5.00
Begin VB.Form frmSurface2
   Appearance      =   0  'Flat
   BackColor       =   &H00C0C0C0&
   Caption         =   "Surface2"
   ClientHeight    =   5295
   ClientLeft      =   300
   ClientTop       =   570
   ClientWidth     =   9135
   BeginProperty Font
      Name            =   "MS Sans Serif"
      Size            =   8.25
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   5295
   ScaleWidth      =   9135
   Begin VB.OptionButton optSurface
      Caption         =   "Volcano"
      Height          =   255
      Index           =   13
      Left            =   0
      TabIndex        =   14
      Top             =   4680
      Width           =   2055
   End
   Begin VB.OptionButton optSurface
      Caption         =   "Pit"
      Height          =   255
      Index           =   12
      Left            =   0
      TabIndex        =   13
      Top             =   4320
      Width           =   2055
   End
   Begin VB.OptionButton optSurface
      Caption         =   "Canyons"
      Height          =   255
      Index           =   11
      Left            =   0
      TabIndex        =   12
      Top             =   3960
      Width           =   2055
   End
   Begin VB.OptionButton optSurface
      Caption         =   "Hill and Hole"
      Height          =   255
      Index           =   10
      Left            =   0
      TabIndex        =   11
      Top             =   3600
      Width           =   2055
   End
   Begin VB.OptionButton optSurface
      Caption         =   "Monkey Saddle"
      Height          =   255
      Index           =   9
      Left            =   0
      TabIndex        =   10
      Top             =   3240
      Width           =   2055
   End
   Begin VB.OptionButton optSurface
      Caption         =   "Splash"
      Height          =   255
      Index           =   0
      Left            =   0
      TabIndex        =   9
      Top             =   0
      Value           =   -1  'True
      Width           =   2055
   End
   Begin VB.OptionButton optSurface
      Caption         =   "Mounds"
      Height          =   255
      Index           =   1
      Left            =   0
      TabIndex        =   8
      Top             =   360
      Width           =   2055
   End
   Begin VB.OptionButton optSurface
      Caption         =   "Bowl"
      Height          =   255
      Index           =   2
      Left            =   0
      TabIndex        =   7
      Top             =   720
      Width           =   2055
   End
   Begin VB.OptionButton optSurface
      Caption         =   "Ridges"
      Height          =   255
      Index           =   3
      Left            =   0
      TabIndex        =   6
      Top             =   1080
      Width           =   2055
   End
   Begin VB.OptionButton optSurface
      Caption         =   "Randomized Ridges"
      Height          =   255
      Index           =   4
      Left            =   0
      TabIndex        =   5
      Top             =   1440
      Width           =   2055
   End
   Begin VB.OptionButton optSurface
      Caption         =   "Hemisphere"
      Height          =   255
      Index           =   5
      Left            =   0
      TabIndex        =   4
      Top             =   1800
      Width           =   2055
   End
   Begin VB.OptionButton optSurface
      Caption         =   "Holes"
      Height          =   255
      Index           =   6
      Left            =   0
      TabIndex        =   3
      Top             =   2160
      Width           =   2055
   End
   Begin VB.OptionButton optSurface
      Caption         =   "Cone"
      Height          =   255
      Index           =   7
      Left            =   0
      TabIndex        =   2
      Top             =   2520
      Width           =   2055
   End
   Begin VB.OptionButton optSurface
      Caption         =   "Saddle"
      Height          =   255
      Index           =   8
      Left            =   0
      TabIndex        =   1
      Top             =   2880
      Width           =   2055
   End
   Begin VB.PictureBox picCanvas
      AutoRedraw      =   -1  'True
      Height          =   5295
      Left            =   2160
      ScaleHeight     =   349
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   461
      TabIndex        =   0
      Top             =   0
      Width           =   6975
   End
Attribute VB_Name = "frmSurface2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Location of viewing eye.
Private EyeR As Single
Private EyeTheta As Single
Private EyePhi As Single
Private Const Dtheta = PI / 20
Private Const Dphi = PI / 20
Private Const Dr = 1
' Location of focus point.
Private Const FocusX = 0#
Private Const FocusY = 0#
Private Const FocusZ = 0#
Private Projector(1 To 4, 1 To 4) As Single
Private TheGrid As RefinedGrid3d
Private Enum SurfaceTypes
    surface_Splash = 0
    surface_Mounds = 1
    surface_Bowl = 2
    surface_Ridges = 3
    surface_RandomRidges = 4
    surface_Hemisphere = 5
    surface_Holes = 6
    surface_Cone = 7
    surface_Saddle = 8
    surface_MonkeySaddle = 9
    surface_HillAndHole = 10
    surface_Canyons = 11
    surface_Pit = 12
    surface_Volcano = 13
End Enum
Private SelectedSurface As SurfaceTypes
Private SphereRadius As Single
Private Const Amplitude1 = 0.25
Private Const Period1 = 2 * PI / 4
Private Const Amplitude2 = 1
Private Const Period2 = 2 * PI / 16
Private Const Amplitude3 = 2
Private Const Xmin = -5
Private Const Zmin = -5
' Project and display the data.
Private Sub DrawData(pic As Object)
Dim X As Single
Dim Y As Single
Dim Z As Single
Dim S(1 To 4, 1 To 4) As Single
Dim T(1 To 4, 1 To 4) As Single
Dim ST(1 To 4, 1 To 4) As Single
Dim PST(1 To 4, 1 To 4) As Single
    MousePointer = vbHourglass
    DoEvents
    ' Make the data.
    CreateData
    ' Scale and translate so it looks OK in pixels.
    m3Scale S, 35, -35, 1
    m3Translate T, 230, 175, 0
    m3MatMultiplyFull ST, S, T
    m3MatMultiplyFull PST, Projector, ST
    ' Transform the points.
    TheGrid.ApplyFull PST
    ' Prevent overflow errors when drawing lines
    ' too far out of bounds.
    On Error Resume Next
    ' Display the data.
    pic.Cls
    TheGrid.Draw pic
    pic.Refresh
    MousePointer = vbDefault
    picCanvas.SetFocus
End Sub
' Return the Y coordinate for these X and
' Z coordinates.
Private Function YValue(ByVal X As Single, ByVal Z As Single)
Dim x1 As Single
Dim z1 As Single
Dim x2 As Single
Dim z2 As Single
Dim D As Single
    Select Case SelectedSurface
        Case surface_Splash
            D = Sqr(X * X + Z * Z)
            YValue = Amplitude1 * Cos(3 * D)
        Case surface_Mounds
            YValue = Amplitude1 * (Cos(Period1 * X) + Cos(Period1 * Z))
        Case surface_Bowl
            YValue = 0.2 * (X * X + Z * Z) - 5#
        Case surface_Ridges
            YValue = Amplitude2 * Cos(Period2 * X) + Amplitude3 * Cos(Period1 * Z) / (Abs(Z) / 3 + 1)
        Case surface_RandomRidges
            YValue = Amplitude2 * Cos(Period2 * X) + Amplitude3 * Cos(Period1 * Z) / (Abs(Z) / 3 + 1) + Amplitude1 * Rnd
        Case surface_Hemisphere
            D = X * X + Z * Z
            If D >= SphereRadius Then
                YValue = 0
            Else
                YValue = Sqr(SphereRadius - D)
            End If
        Case surface_Holes
            x1 = (X + Xmin / 2)
            z1 = (Z + Xmin / 2)
            x2 = (X - Xmin / 2)
            z2 = (Z - Xmin / 2)
            YValue = Amplitude3 - _
                1 / (x1 * x1 + z1 * z1 + 0.1) - _
                1 / (x2 * x2 + z1 * z1 + 0.1) - _
                1 / (x1 * x1 + z2 * z2 + 0.1) - _
                1 / (x2 * x2 + z2 * z2 + 0.1)
        Case surface_Cone
            D = 2 * (Amplitude3 - Sqr(X * X + Z * Z))
            If D < -Amplitude3 Then D = -Amplitude3
            YValue = D
        Case surface_Saddle
            YValue = (X * X - Z * Z) / 10
        Case surface_MonkeySaddle
            x1 = 1.5 * X
            z1 = 1.5 * Z
            YValue = (x1 * x1 * x1 / 3 - x1 * z1 * z1) / 50
        Case surface_HillAndHole
            YValue = -5 * X / (X * X + Z * Z + 1)
        Case surface_Canyons
            YValue = Sin(X * 1.5) * Z * Z * Z / 30
        Case surface_Pit
            YValue = -3 + (X * X + Z * Z) / 10 + Sin(2 * Sqr(X * X + Z * Z)) / 2
        Case surface_Volcano
            YValue = -Abs(X * X + Z * Z - 9) / 10
    End Select
End Function
Private Sub optSurface_Click(Index As Integer)
    SelectedSurface = Index
    DrawData picCanvas
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyLeft
            EyeTheta = EyeTheta - Dtheta

        Case vbKeyRight
            EyeTheta = EyeTheta + Dtheta

        Case vbKeyUp
            EyePhi = EyePhi - Dphi

        Case vbKeyDown
            EyePhi = EyePhi + Dphi

        Case Else
            Exit Sub
    End Select
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData picCanvas
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case Asc("+")
            EyeR = EyeR + Dr

        Case Asc("-")
            EyeR = EyeR - Dr

        Case Else
            Exit Sub
    End Select
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData picCanvas
End Sub
Private Sub Form_Load()
    ' Initialize the eye position.
    EyeR = 10
    EyeTheta = PI * 0.2
    EyePhi = PI * 0.1
    ' Initialize the projection transformation.
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    ' Project and draw the data.
    Me.Show
    DrawData picCanvas
End Sub
' Create the surface.
Private Sub CreateData()
Const Subdivisions = 3
Const MajorDx = 0.6
Const MajorDz = 0.6
Const MinorDx = MajorDx / Subdivisions
Const MinorDz = MajorDz / Subdivisions
Const NumX = -2 * Xmin / MajorDx
Const NumZ = -2 * Zmin / MajorDz
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim X As Single
Dim Y As Single
Dim Z As Single
Dim x1 As Single
Dim y1 As Single
Dim z1 As Single
Dim x2 As Single
Dim y2 As Single
Dim z2 As Single
Dim pline As Polyline3d
    Set TheGrid = New RefinedGrid3d
    SphereRadius = (Xmin + 3 * MajorDx) * (Xmin + 3 * MajorDx)
    ' Make polylines parallel to the X axis.
    X = Xmin
    For i = 1 To NumX
        Set pline = New Polyline3d
        z1 = Zmin
        ' Get the starting point.
        y1 = YValue(X, z1)
        For j = 1 To NumZ - 1
            For k = 1 To Subdivisions
                z2 = z1 + MinorDz
                y2 = YValue(X, z2)
                pline.AddSegment X, y1, z1, X, y2, z2
                y1 = y2
                z1 = z2
            Next k
        Next j
        TheGrid.Polylines.Add pline
        X = X + MajorDx
    Next i
    ' Make polylines parallel to the Z axis.
    Z = Zmin
    For i = 1 To NumZ
        Set pline = New Polyline3d
        x1 = Xmin
        ' Get the starting point.
        y1 = YValue(x1, Z)
        For j = 1 To NumX - 1
            For k = 1 To Subdivisions
                x2 = x1 + MinorDx
                y2 = YValue(x2, Z)
                pline.AddSegment x1, y1, Z, x2, y2, Z
                y1 = y2
                x1 = x2
            Next k
        Next j
        TheGrid.Polylines.Add pline
        Z = Z + MajorDz
    Next i
End Sub